home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-01
/
cexpert.zip
/
MCH4.LST
< prev
next >
Wrap
File List
|
1990-09-15
|
19KB
|
799 lines
Listing 4-1 C/C++ Program CAR, CDR, ATOM
/* cons.h
typedef struct _cons { /* a cons-cell */
union {
struct _cons *p;
char *s;
} car;
struct _cons *cdr; /* usually points to a sublist */
unsigned char type; /* the types of the pointers in the cells */
} cons;
#define CAR_STRING 1
#define CAR_INTEGER 2
#define CAR_LIST 4
#define CDR_STRING 8
#define CDR_INTEGER 16
#define CDR_LIST 32
#define C_FILE 0
#define C_STRING 1
#define ATOM(x) ((x)->type != CAR_LIST)
#define CAR(x) (x)->car.p
#define CDR(x) (x)->cdr
#define HEAD CAR
#define TAIL CDR
cons *mkcons(),*lread();
cons *nsubst(),*copy_list(),*mklist2();
cons *member(),*nconc(),*nreverse();
cons *unify_equal(),*unify_term_c(),*unify_pred_c(),*unify_list_c_1();
cons *unify_pred_nv(),*unify_list_nv_1();
cons *twotees(),*ltwotees();
cons *join_subst(),*subst_list();
Listing 4-2 Utility Functions for LISP Conversion
/*
** UTIL.C
**
** Emulation of LisP utilities
*/
#include <stdio.h>
#include "cons.h"
#include "goal.h"
/*
** nsubst(): replace surgically every occurrence of _old_ with _new_ in the
** list _list_.
*/
/*--------------------------------------------------nth_list()-----------*/
/*
** Usage:
** E.x. n = 2, list = (((?x 3)(?y 5))(?z 1)((?m 4)))
** nth_list(n,list) ===> (?z 1)
**
*/
cons *nth_list(n,list)
int n;
cons *list;
{
int i;
cons *substp = list;
for(i = 1; i < n; i++)
{
substp = CDR(substp);
}
return(mkcons(CAR_LIST,CAR(substp),NULL));
}
/*---------------------------------------------------mkcons()-----------*/
/*
** Usage:
** E.x. mkcons(CAR_LIST,(?x 1),(?y 2)) ===> ((?x 1)(?y 2))
**
*/
cons *mkcons(type,head,tail)
cons *head,*tail;
{
cons *p;
if (p = (cons *) malloc(sizeof(cons))) {
p->type = type;
p->car.p = head;
p->cdr = tail;
} else {
puts("\n*** Yow! Out of core ***\n");
}
return p;
}
/*-----------------------------------------------------killcons-----------*/
killcons(p)
cons *p;
{
if (p != NULL) {
if ((p->type & CAR_LIST) == CAR_LIST) {
killcons(p->car.p);
killcons(p->cdr);
} else if ((p->type & CAR_STRING) == CAR_STRING) {
free(p->car.s); /* get rid of the string */
}
free(p);
}
}
/*----------------------------------------------------nsubst()------------*/
cons *nsubst(new,old,list)
char *new,*old;
cons *list;
{
cons *t;
char *strsave();
if (list == NULL) {
t = NULL;
} else if (list->type == CAR_STRING) {
if (!strcmp(list->car.s,old)) {
killcons(list);
t = mkcons(CAR_STRING,strsave(new),NULL);
} else {
t = list;
}
} else {
list->car.p = nsubst(new,old,list->car.p);
list->cdr = nsubst(new,old,list->cdr);
t = list;
}
return t;
}
/*-----------------------------------------------------copy_list()-------*/
/*
** copy_list(): copy a list structure, down to the last atom, string &c.
*/
cons *copy_list(list)
cons *list;
{
cons *t;
if (list == NULL) {
t = NULL;
} else if (list->type == CAR_STRING) {
t = mkcons(CAR_STRING,strsave(list->car.s),NULL);
} else {
t = mkcons(CAR_LIST,copy_list(list->car.p),copy_list(list->cdr));
}
return t;
}
/*-----------------------------------------------------length()---------*/
/*
** length(): returns the length of a list (counting only the 'top' or
** backbone elements, i.e.:
** length( '(a b (c d) e)) == 4, not 5
*/
int length(lp)
cons *lp;
{
int l = 0;
if (ATOM(lp))
return 0;
while (lp != NULL) {
++l;
lp = lp->cdr;
}
return l;
}
/*----------------------------------------------------mklist2()----------*/
/*
** mklist2(): make a two-element list out of the given string arguments.
**
** Usage: E.x. mklist2("x","y") ===> (x y)
**
*/
cons *mklist2(foo,bar)
char *foo,*bar;
{
return mkcons(CAR_LIST,mkcons(CAR_STRING,strsave(foo),NULL),
mkcons(CAR_LIST,mkcons(CAR_STRING,strsave(bar),NULL),
NULL));
}
/*-------------------------------------------------member_list()----------*/
/*
** member_list(): searches for the first occurrence of list1 in the list2.
** Searches are done on the top-level only, and only deal with length(list1)
** equal 1.
** Return SUCCEED of FAIL
** Usage: E.g. member_list((?x 1),((?y 2)(?x 1))) ===> SUCCEED
** member_list((?x 1),(((?x 1)))) ===> FAIL
**
** Author: Sony Y. Song
** Date: 7/13/88
**
*/
cons *member_list(list1,list2)
cons *list1,*list2;
{
int i;
cons *temp1;
if(list1 == NULL)
{
return SUCCEED;
}
for(i = 1; i <= length(list2); i++)
{
temp1 = nth_list(i,list2);
if(equal(list1,CAR(temp1)))
{
return SUCCEED;
}
}
return FAIL;
}
/*----------------------------------------------------variablep()----------*/
/*
** variablep(): Quick function, returns 'true' if the first character of
** var is '?' and 'false' if not.
*/
int variablep(var)ècons *var;
{
return (ATOM(var) && *(var->car.s) == '?');
}
/*-----------------------------------------------------equal()-------------*/
/*
** equal(): determine whether two lisp constructs are equal
*/
int equal(l1,l2)
cons *l1,*l2;
{
if (l1 == NULL && l2 == NULL) {
return 1;
} else if (l1 == NULL || l2 == NULL) {
return 0;
} else if (l1->type == CAR_STRING && l1->type == CAR_STRING) {
return !strcmp(l1->car.s,l2->car.s);
} else if (l1->type == CAR_LIST && l2->type == CAR_LIST) {
return (equal(l1->car.p,l2->car.p) && equal(l1->cdr,l2->cdr));
}
}
/*------------------------------------------------nconc()----------------*/
/*
** nconc(): surgically concatenate two lists. Appends list2 to the end of
** list 1 and returns the modified list1/list2 complex.Only used in backward
** chaining.
** Modified from nconc_lisp. Add some test cases.
** Usage: E.g. nconc(((?x 1)(?y 2)),(?z 3)) ===> ((?x 1)(?y 2)(?z 3))
** E.g. nconc((t t),(t t)) ===> (t t)
** E.g. nconc((?x 1),(?x 1)) ===> (?x 1)
**
** 10-Jun-88 John Källén Original code.
** 14-Jul-88 Sony Y.Song Add some test cases.
*/
cons *nconc(list1,list2)
cons *list1,*list2;
{
cons *olist1;
olist1 = list1;
if (list1 == NULL)
{
return list2;
}
if(equal(list1,ltwotees()) && equal(list2,ltwotees()))
{
olist1 = ltwotees();è return olist1;
}
if(!equal(list1,ltwotees())&&equal(list2,ltwotees()))
{
return list1;
}
if(!equal(list2,ltwotees())&&equal(list1,ltwotees()))
{
return list2;
}
if(equal(list1,list2))
{
return list1;
}
if(!ATOM(CAR(list1))&&member_list(list1,list2))
{
return list2;
}
while (list1->cdr != NULL) {
list1 = list1->cdr;
}
list1->cdr = list2;
return olist1;
}
/*----------------------------------------------nconc_lisp()----------------*/
/*
** nconc_lisp():surgically concatenate two lists. Appends list2 to the end of
** list 1 and returns the modified list1/list2 complex.
*/
cons *nconc_lisp(list1,list2)
cons *list1,*list2;
{
cons *olist1;
olist1 = list1;
if (list1 == NULL)
{
return list2;
}
while (list1->cdr != NULL) {
list1 = list1->cdr;
}
list1->cdr = list2;
return olist1;
}
/*--------------------------------------------------nreverse()-------------*/
/*
** nreverse(): destructively reverses a listè*/
cons *nreverse(list)
cons *list;
{
cons *tmpcdr;
if (list == NULL || list->cdr == NULL) {
return list;
}
tmpcdr = list->cdr;
list->cdr = NULL;
return nconc(nreverse(tmpcdr),list);
}
/*---------------------------------------------------fgetword()------------*/
/*
** read a space-delimited word from the input file _fp_ and put it in _buf_
*/
void fgetword(fp,buf)
FILE *fp;
char *buf;
{
int c;
while ((c = getc(fp)) != EOF && strchr(" \t\n",c)) /* skip whitespace */
;
*buf++ = c;
while ((c = getc(fp)) != EOF && !strchr(" \t\n()",c)) { /* get all reals */
*buf++ = (char) c;
}
*buf = '\0'; /* delimit */
}
/*---------------------------------------------------push()----------------*/
/*
** push(item,list): the item is consed onto the front of the list.
** Usage: E.g. push(((?x 1)),((?y 2))) ===> (((?x 1))(?y 2))
**
** Author: Sony Y. Song
** Date: 7/07/88
*/
cons *push(item,list)
cons *item,*list;
{
return mkcons(CAR_LIST,item,list);
}
Listing 4-3 Substitution a Sample LISP-C Conversion Program
/*
** substitu.c: Functions for manipulating substitutions.
**
*/
/*--------------------------------------------------include--------------*/
#include <stdio.h>
#include "cons.h"
/*--------------------------------------------------twotees()------------*/
cons *twotees()
{
static cons *tt = NULL;
if (tt == NULL) {
tt = mklist2("t","t");
}
return tt;
}
/*--------------------------------------------------ltwotees()------------*/
cons *ltwotees()
{
static cons *ltt = NULL;
if (ltt == NULL) {
ltt = mkcons(CAR_LIST,twotees(),NULL);
}
return ltt;
}
/*--------------------------------------------------lltwotees()------------*/
cons *lltwotees()
{
static cons *lltt = NULL;
if (lltt == NULL) {
lltt = mkcons(CAR_LIST,ltwotees(),NULL);
}
return lltt;
}
/*--------------------------------------------------join_subst()------------*/è
/*
** z1 is subst for ONE term.
*/
cons *join_subst(z1,z2)
cons *z1,*z2;
{
cons *retval;
if (equal(z1,ltwotees())) {
return z2;
} else if (equal(z2,ltwotees())) {
return z1;
} else {
return(mkcons(CAR_LIST,z1,z2));
}
}
/*--------------------------------------------------subst_list()------------*/
/*
/* THE EXAMPLE DISCUSSED IN THE TEXT
/*
** Variable substitution
** %% Use of system fn like subst would be real efficient, except that it
** does not deal with nonrecursiveness.
** Performs a variable substitution on list, nonrecursively
** (only one substitution applied to each atomic term).
** Usage: E.g. subst_list((p ?x ?y),((?x 1)(?y 2))) ===> (p 1 2)
*/
cons *subst_list(list,substi)
cons *substi,*list;
{
cons *new_list = NULL;
cons *substp;
cons *term;
cons *tmp;
while (list != NULL) {
term = list->car.p;
substp = substi; /* get 1st substitution */
while (substp != NULL) {
if (term->type == CAR_STRING && !strcmp(term->car.s,
substp->car.p->car.p->car.s)) {
term = substp->car.p->cdr->car.p;
break;
}
substp = substp->cdr; /* make more subst's */
}
new_list = nconc(new_list,mkcons(CAR_LIST,copy_list(term),NULL));
list = list->cdr;è }
return new_list;
}
/*
/* THE ABOVE IS THE EXAMPLE DISCUSSED IN THE TEXT.
/*
/*--------------------------------------------------subst_prop()------------*/
/*
** subst_prop(): performs a variable substitution on proposition
** Returns a copy of the proposition with replacements according to the
** substitution list.
** Usage: E.g. subst_prop(((p ?x)(q ?y)),((?x 1)(?y 2))) ===> ((p 1)(q 2))
**
** Author: Sony Y. Song
** Date: 7/12/88
*/
cons *subst_prop(list,substi)
cons *substi,*list;
{
int i;
cons *temp1,*temp2;
temp1 = NULL;
if(list == NULL)
{
killcons(temp1);
killcons(temp2);
return NULL;
}
for(i = 1; i <= length(list); i++)
{
temp2 = nth_list(i,list);
temp1 = nconc(temp1,
mkcons(CAR_LIST,subst_list(CAR(temp2),substi),NULL));
}
killcons(temp1);
killcons(temp2);
return temp1;
}
/*--------------------------------------------------subst_pred()------------*/
/*
** subst_pred(): Performs nonrecursive variable substitution on a predicate
** Would be more mem-efficient if result SHARED with pred.
** Usage: E.g. subst_pred((p ?x ?y),((?x 1)(?y 2))) ===> (p 1 2)
*/
cons *subst_pred(pred,subst)
cons *pred,*subst;
{ return subst_list(pred,subst);
}
cons *substitute_pred(pred,subst)
cons *pred,*subst;
{
int i,j;
cons *new_list = NULL;
cons *substp;
cons *term;
cons *tmp;
for(i = 1; i <= length(pred); i++)
{
/* term = CAR(nth_list(i,pred));*/
substp = subst;
for(j = 1; j <= length(subst); j++)
{
;
}
}
}
/*--------------------------------------------------subst_substlist()-----*/
/*
** subst_substlist(): perform a substitution on a substitution list
** s-s( (((?x 1)) ((?x 2))) , ((?x ?y)) ) ==> (((?y 1)) ((?y 2)))
*/
cons *subst_substlist(substlist,subst)
cons *substlist,*subst;
{
cons *new_substlist = NULL;
cons *new_subst = NULL;
cons *new_pair = NULL;
cons *term,*substp,*substip,*tmp;
while (substlist != NULL) { /* for each substitution */
new_subst = NULL;
substp = substlist->car.p;
while (substp != NULL) { /* for each pair */
term = substp->car.p->car.p;
substip = subst;
while (substip != NULL) { /* for each substitution-pair */
if (!strcmp(term->car.s,substip->car.p->car.p->car.s)) {
term = substip->car.p->cdr->car.p;
break;
}
substip = substip->cdr;
}
new_subst = nconc(new_subst,
mkcons(CAR_LIST,è mkcons(CAR_LIST,
copy_list(term),
mkcons(CAR_LIST,
copy_list(substp->car.p->cdr->car.p),
NULL)),
NULL));
substp = substp->cdr;
}
new_substlist = nconc(new_substlist,mkcons(CAR_LIST,new_subst,NULL));
substlist = substlist->cdr;
}
return new_substlist;
}
/*----------------------------------------------test_subst_used()-----*/
/*
** test_subst_used():Tells if substitution has been used.
** Usage: E.g.
** test_subst_used(((?x 5)),(((?x 1)))) ===> 0
** test_subst_used(((?x 5)),(((?x 5)))) ===> 1
**
** Author: Sony Y.Song
** Date: 7/9/88
*/
int test_subst_used(list1,prev_subst)
cons *list1,*prev_subst;
{
int i,j;
int flag = 0;
cons *temp1,*temp2;
for(i=1;i<=length(list1);i++)
{
flag = 0;
temp1 = nth_list(i,list1);
for(j=1;j<=length(prev_subst);j++)
{
temp2 = nth_list(j,prev_subst);
if(equal(temp1,CAR(temp2)))
{
flag = 1;
break;
}
}
if(flag == 1)
{
return 1; /*at least one not used*/
}
}
return 0; /*all used*/è}
Listing 4-4 The LISP Code for Substitution
;;; **********************************************************************
;;; Variable substitution
;;; %% Use of system fn like subst would be real efficient, except that it
;;; does not deal with nonrecursiveness.
;;; Performs a variable substitution on list, nonrecursively
;;; (only one substitution applied to each atomic term).
(defmacro aif (test-form &rest body)
`(let ((it ,test-form))
(if it ,@body)))
(defun Subst-List (list subst)
(declare (special subst))
(mapcar #'(lambda (term) (aif (assoc term subst) (cdr it) term)) list))
;;;
;;; THE ABOVE IS THE EXAMPLE DISCUSSED IN THE TEXT
;;;
;;; Performs a variable substitution on expression, nonrecursively
;;; Used backtrack
(defun Subst-Exp (exp subst)
(declare (special exp subst))
(cond ((not exp) nil)
((atom exp)
(or (some #'(lambda (s) (when (eq (car s) exp) (cdr s))) subst)
exp))
(t (mapcar #'(lambda (piece) (subst-exp piece subst)) exp))))
;;; Performs nonrecursive variable substitution on a predicate
;;; Would be more mem-efficient if result SHARED with pred.
;;; NB: Subst not applied to first term!!
(defun Subst-Pred (pred subst)
(declare (special subst))
(cons (car pred)
(mapcar #'(lambda (term) (aif (assoc term subst) (cdr it) term))
(cdr pred))))
;;; Performs a variable substitution on proposition, nonrecursively
;;; (only one substitution applied to each atomic term).
;;; NB: Subst not applied to first term!!
(defun Subst-Prop (prop subst)
(declare (special prop subst))
(cond ((not prop) nil)
((atom prop)
(or (some #'(lambda (s) (when (eq (car s) prop) (cdr s))) subst)
prop))
(t (cons (car prop)
(mapcar #'(lambda (piece) (subst-Prop piece subst))
(cdr prop))))))
;;; This is slower, but more memory-efficient...è; (t (let ((car (substitute-nonrecursive (car proposition) substitution))
; (cdr (substitute-nonrecursive (cdr proposition) substitution)))
; (if (and (eq car (car proposition)) (eq cdr (cdr proposition)))
; proposition (cons car cdr))))))
(defun Subst-Substlist (substlist subst)
(declare (special subst))
(mapcar #'(lambda (sl)
(mapcar #'(lambda (s) (aif (assoc (car s) subst)
(list* (cdr it) (cdr s)) s))
sl))
substlist))
;;; **********************************************************************
;;; Tells if substitution has been used. **** Used everywhere ***
;;; I.e., there is a prev-subst in prev-substs that is contained in poss-subst.
;;; (subst-used? '((?x . 5)) '(((?x . 1)))) --> NIL
;;; (subst-used? '((?x . 5)) '(((?x . 5)))) --> T
;;; (subst-used? '((?x . 5)) '(((?x . 5) (?y . 3)))) --> NIL
;;; {because there might be some other way to get ?y}
;;; (subst-used? '((?x . 1) (?y . 1)) '(((?x . 1)))) --> T
;;; {Because this is clearly not a new solution when we just want a new ?x}
;;; Heuristic is, "I don't want a solution that is the Same (for my
;;; purposes) as any of these"
(defun Subst-Used? (poss-subst prev-substs)
(declare (special poss-subst))
; (find subst prev-substs :test #'equal))
(some #'(lambda (prev-subst)
(subset-equal prev-subst poss-subst))
prev-substs))
#|
we use #'SUBSET-EQUAL here because we want cases like
(stash '(and (p 1) (r 1 2) (r 2 2)))
(create-rule nil :premise '(r ?x ?y) :conclusion '(p ?x))
(query-all '(p ?x))
to find the solution (?x . 2). It WON'T be found if
(achieve '(r ?x ?y) '(((?x . 1)))) returns ((?x . 1) (?y . 2))
Optional guts for above:
(let ((some-are-same?))
(if (dolist (sub prev-subst)
(if (member-equal sub poss-subst) (setq some-are-same? t)
(if (and (member (car sub) poss-subst ; really need :key
:test #'(lambda (item elt) (eq item (car elt))))
(not (member-equal sub poss-subst)))
; one of the subs in prev is different.
(return t))))
nil
some-are-same?))) |#
;;; Tells if containee is a condensed version of container.
;;; Used in find-goal-stack.
(defun Condensed-Substs? (containee container)
(and (equal (list-length containee) (list-length container))
(every #'subset-equal containee container)))